home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual Foxpro 6.0 (Ent. Edition) / Vf6ent Extractor.EXE / TOOLS / INETWIZ / SERVER / SERVER.PRG < prev    next >
Encoding:
Text File  |  1998-05-26  |  32.8 KB  |  1,189 lines
  1. #DEFINE CRLF CHR(13)+CHR(10)
  2. #DEFINE WWWCAPTION_LOC 'WWW Data Server'
  3. #DEFINE NOFXTOOLS_LOC    'Missing FOXTOOLS.FLL'
  4. #DEFINE NOIDC_LOC    "No .IDC file was specified.  The server cannot continue."
  5. #DEFINE IDCNOTFOUND1_LOC    "Specified .IDC file ("
  6. #DEFINE IDCNOTFOUND2_LOC    ") not found.  The server cannot continue."
  7. #DEFINE IDCBADDATA1_LOC ") does not contain correct data or cannot be accessed. The template entry could not be located.  The server cannot continue."
  8. #DEFINE IDCBADDATA2_LOC    ") does not contain correct data or cannot be accessed. The SQL statement entry could not be located.  The server cannot continue."
  9. #DEFINE BADSQL_LOC "The SQL statement supplied by the IDC file could not be understood.  The server cannot continue."
  10. #DEFINE NOSQL1_LOC    'The SQL statement FROM table ['
  11. #DEFINE NOSQL2_LOC    '] not found.<BR>Table specified must be in PATH of data server specified in VFPIS.INI.<BR>'+CRLF+'SQL String: <HR>'
  12. #DEFINE BADCMD_LOC    'The command generated an error.<BR>Please Contact the system administrator.<BR>'+CRLF+'SQL String: <HR>'
  13. #DEFINE BADCONN1_LOC    "The connection to "
  14. #DEFINE BADCONN2_LOC    " as "
  15. #DEFINE BADCONN3_LOC    " could not be made.  The server cannot continue."
  16. #DEFINE NOTEMPLATE_LOC 'The template file could not be located.  The server cannot continue.'
  17. #DEFINE BADTEMPLATE1_LOC    'The template file ('
  18. #DEFINE BADTEMPLATE2_LOC    ') could not be opened successfully.  The server cannot continue.'
  19. #DEFINE BADTEMPLATE3_LOC    ") contained a mismatched BeginDetail/EndDetail structure.  The server cannot continue."
  20. #DEFINE BADTEMPLATE4_LOC    "The detail line in "
  21. #DEFINE BADTEMPLATE5_LOC    " contains a mismatched symbol structure.  The server cannot continue."
  22. #DEFINE BADTEMPLATE6_LOC    "The template file contained an improperly formed IF construct.  The server cannot continue."
  23. #DEFINE BADTEMPLATE7_LOC    " contained a mismatched If/EndIf structure.  The server cannot continue."
  24. #DEFINE NODATASTREAM_LOC    "An error occurred trying to create your data stream.  The server cannot continue."
  25. #DEFINE NOMATCHES_LOC        "No matches found."
  26. #DEFINE RETURNED_LOC        "Returned"
  27. #DEFINE FAILEDSEARCH_LOC    "FoxPro Search Failed"
  28. #DEFINE FALSE_LOC    "FALSE"
  29. #DEFINE TRUE_LOC    "TRUE"
  30. #DEFINE ERROCCUR_LOC    "Error occured :  "
  31. #DEFINE ERRMESS_LOC        "Error message :  "
  32. #DEFINE ERRNUM_LOC        "Error number  :  "
  33. #DEFINE ERRPROC_LOC        "Procedure name:  "
  34. #DEFINE ERRLINE_LOC        "Line number   :  "
  35. #DEFINE ERRALIAS_LOC    "Alias         :  "
  36. #DEFINE ERRREC_LOC        "Record number :  "
  37.  
  38.  
  39. LOCAL lcProgram,lcFullPath,lnAtPos,lcFoxTools,lcError,lcFileName
  40. LOCAL lcScreenIcon,lcScreenCaption,lcSetPath,lnSelect
  41. PRIVATE gcINIFile,gcHTTPRoot,gcScriptRoot,gcSemaphoreRoot,gcPath
  42.  
  43. SET TALK OFF
  44. SET ESCAPE OFF
  45. SET COLLATE TO 'MACHINE'
  46. SET COMPATIBLE OFF
  47. SET CONFIRM ON
  48. SET DECIMALS TO 9
  49. SET EXACT OFF
  50. SET EXCLUSIVE OFF
  51. SET MEMOWIDTH TO 1024
  52. SET MULTILOCKS ON
  53. SET POINT TO '.'
  54. SET SAFETY OFF
  55. SET UDFPARMS TO VALUE
  56. SET MESSAGE TO ' '
  57. lcProgram=SYS(16)
  58. lnAtPos=RATC('\',lcProgram)
  59. lcFullPath=LEFTC(lcProgram,lnAtPos)
  60. CD (lcFullPath)
  61. lcFoxTools='foxtools.fll'
  62. IF NOT FILE(lcFoxTools)
  63.     lcFoxTools=HOME()+lcFoxTools
  64. ENDIF
  65. IF NOT FILE(lcFoxTools)
  66.     =MESSAGEBOX(NOFXTOOLS_LOC,16,_screen.Caption)
  67.     RETURN .F.
  68. ENDIF
  69. ON ERROR
  70. ERASE ERROR.txt
  71. SET LIBRARY TO (lcFoxTools) ADDITIVE
  72.  
  73. lnSelect=SELECT()
  74. lcSetPath=SET('PATH')
  75. lcOnError=ON('ERROR')
  76. lcScreenIcon=_screen.Icon
  77. _screen.Icon='net13.ico'
  78. lcScreenCaption=_screen.Caption
  79. _screen.Caption=WWWCAPTION_LOC 
  80.  
  81. gcINIFile="vfpis.ini"
  82. gcHTTPRoot=""
  83. gcScriptRoot=""
  84. gcSemaphoreRoot=FULLPATH('\temp\')
  85. ON ERROR =.F.
  86. MD (gcSemaphoreRoot)
  87. ON ERROR
  88. gcPath=""
  89.  
  90. ON ERROR DO ErrorHandler WITH ERROR(),MESSAGE(),PROGRAM(),LINENO(),MESSAGE(1)
  91.  
  92. *Read the initialization file and set up root paths.  If the
  93. *INI file doesn't exist or is empty, ask the user to set one up.
  94.  
  95. IF FILE(gcINIFile)
  96.     =readini(gcINIFile)
  97. ENDIF
  98. IF EMPTY(gcHTTPRoot)
  99.     DO FORM SpecRoot
  100. ENDIF
  101. IF EMPTY(gcScriptRoot)
  102.     gcScriptRoot=gcHTTPRoot
  103. ENDIF
  104. SET PATH TO (gcPath)
  105. CLOSE ALL DATABASES
  106. CLOSE ALL
  107. lcFileName=LOWER(FULLPATH('querylog.dbf',lcProgram))
  108. IF NOT FILE(lcFileName)
  109.     CREATE TABLE (lcFileName) (TimeStamp T, IDCFile C(32), Parameters M)
  110.     USE
  111. ENDIF
  112. USE (lcFileName) ALIAS QueryLog EXCLUSIVE
  113.  
  114. DO FORM server
  115. CLOSE ALL DATABASES
  116. CLOSE ALL
  117. SELECT (lnSelect)
  118. IF NOT EMPTY(lcScreenCaption)
  119.     _screen.Caption=lcScreenCaption
  120. ENDIF
  121. IF NOT EMPTY(lcScreenIcon)
  122.     _screen.Icon=lcScreenIcon
  123. ENDIF
  124. SET MESSAGE TO
  125. SET PATH TO (lcSetPath)
  126. IF EMPTY(lcError)
  127.     ON ERROR
  128. ELSE
  129.     ON ERROR &lcError
  130. ENDIF
  131.  
  132. RETURN
  133.  
  134.  
  135.  
  136. FUNCTION executeprocess(tcFileName)
  137. LOCAL lcDataFile,lcAckFile,lnDFH,lnAFH,lcParameter
  138.  
  139.     lcDataFile=gcSemaphoreRoot+JustStem(ALLTRIM(tcFileName))+".dat"
  140.     lcAckFile=gcSemaphoreRoot+JustStem(ALLTRIM(tcFileName))+".ack"
  141.     lnDFH=FOPEN(lcDataFile)
  142.     lcParameter=""
  143.     IF lnDFH > 0
  144.         DO WHILE NOT FEOF(lnDFH)
  145.             lcParameter=lcParameter+FREAD(lnDFH,1000)
  146.         ENDDO
  147.         =FCLOSE(lnDFH)
  148.         STRTOFILE(GenPage(lcParameter),lcDataFile)
  149.         * Create Acknowledgement file
  150.         STRTOFILE(" ",lcAckFile)
  151.     ELSE
  152.         * Error opening data file
  153.     ENDIF
  154. ENDFUNC
  155.  
  156.  
  157. * HTML Page Generation Program
  158. * This program takes a SQL Query, and several other parameters and
  159. * generates an output document in HTML which can be used by a WWW
  160. * Browser.
  161. * This function goes for bulletproof simple error handling when it is interpreting
  162. * an .HTX file.  If it runs into a logical error, it will simply attempt to continue.
  163. ****************
  164. FUNCTION genpage(cParameters)
  165.  
  166.     LOCAL lnAtPos,lcFileName,lcAlias
  167.     LOCAL lFailure, cResultPage, lcError, lnSelect
  168.     LOCAL cSQLStatement, cKeyColumn, cDescriptColumn, ;
  169.         cBackgroundImg, iCount, cTmpString, cPrevNext, ;
  170.         IDCFile, lcTemplate, lcLine, lcTmpLine, ;
  171.         lcLineCopy, lFailure, cExecSQLString, lhTemplate, llDone, ;
  172.         llGetNewLine, lcTmpExp, lcExp1, lcExp2, lcOperator, lcIfStatement, ;
  173.         lcTrueStatement, lcFalseStatement, lcHTMLPath, lcIDCFile, ;
  174.         lcDefErr, llDefaultError, lcReturnData, llReturnData
  175.  
  176.     *These symbols, we want available in the sub programs.  They will all be available,
  177.     *along with all of the parsed in environment variables, to the functions that execute
  178.     *conditionals and detail lines.  This allows those functions to simply utilize their
  179.     *environment.
  180.  
  181.     PRIVATE laEnvVariables, lnEnvVariables, IDC_DataSource, IDC_Template, ;
  182.         IDC_SQLStatement, IDC_DefaultParameters, IDC_Expires, IDC_MaxFieldSize, ;
  183.         IDC_Password, IDC_RequiredParameters, IDC_Username, laDefaultParameters, ;
  184.         laRequiredParameters, CurrentRecord, laTables, CommandSuccess, ;
  185.         lnRecordsReturned, IDC_MaxRecords
  186.  
  187.     CommandSuccess="FALSE"
  188.     lcAlias=''
  189.  
  190.     *Parse out all of the environment variables and HTML variables that are
  191.     *sent to us via the CGI script (contained in cParameters) and place them
  192.     *in an array for ease of reference.  The variables are placed in an array
  193.     *as VARIABLE_NAME, VALUE pairs.
  194.     lnEnvVariables=0
  195.     DIMENSION laEnvVariables[1,2]
  196.  
  197.     IF LEFT(cParameters,1)=='&'
  198.         cParameters=ALLTRIM(SUBSTR(cParameters,2))
  199.     ENDIF
  200.  
  201.     lnEnvVariables=ParseVars(cParameters,@laEnvVariables,.T.)
  202.  
  203.     *Parse out the contents of QUERY_STRING if it is not empty.
  204.     IF NOT EMPTY(getparam("QUERY_STRING"))
  205.         lnEnvVariables=ParseVars(getparam("QUERY_STRING"),@laEnvVariables)
  206.     ENDIF
  207.  
  208.     *Find out if the user has turned off default error processing for the
  209.     *executable command.
  210.     lcDefErr=getparam("DefError")
  211.     IF UPPER(ALLT(lcDefErr))=="OFF"
  212.         llDefaultError=.F.
  213.     ELSE
  214.         llDefaultError=.T.
  215.     ENDIF
  216.  
  217.     *Find out if the user would like the data back as a block of data.
  218.     lcReturnData=getparam("ReturnAsFile")
  219.     IF UPPER(ALLT(lcReturnData))=="ON"
  220.         llReturnData=.T.
  221.     ELSE
  222.         llReturnData=.F.
  223.     ENDIF
  224.  
  225.     *Build an absolute path representing where the calling HTML page was located.
  226.     lcHTMLPath=BldPath()
  227.  
  228.     *Get pointer to .IDC file via passed in HTML parameter
  229.     lcIDCFile=getparam("IDCFile")
  230.     IF NOT EMPTY(lcIDCFile)
  231.         m.IDCFile=LOWER(FULLPATH(lcIDCFile))
  232.         IF NOT FILE(m.IDCFile)
  233.             m.IDCFile=LOWER(FULLPATH(gcScriptRoot+lcIDCFile))
  234.             IF NOT FILE(IDCFile)
  235.                 m.IDCFile=LOWER(FULLPATH(lcHTMLPath+lcIDCFile))
  236.                 IF NOT FILE(m.IDCFile)
  237.                     m.IDCFile=LOWER(FULLPATH(gcHTTPRoot+lcIDCFile))
  238.                 ENDIF
  239.             ENDIF
  240.         ENDIF
  241.         m.IDCFile=LOWER(FULLPATH(m.IDCFile))
  242.     ENDIF
  243.  
  244.     *Append query log
  245.     lnSelect=SELECT()
  246.     SELECT QueryLog
  247.     IF RECCOUNT()>=1000
  248.         ZAP
  249.     ENDIF
  250.     INSERT INTO QueryLog (TimeStamp, IDCFile, Parameters) ;
  251.             VALUES (DATETIME(), lcIDCFile, cParameters)
  252.     SELECT 0
  253.  
  254.     IF EMPTY(m.IDCFile)
  255.         =Cleanup()
  256.         RETURN errorpage(NOIDC_LOC)
  257.     ENDIF
  258.     IF NOT FILE(m.IDCFile)
  259.         =Cleanup()
  260.         RETURN errorpage(IDCNOTFOUND1_LOC+lcIDCFile+IDCNOTFOUND2_LOC)
  261.     ENDIF
  262.  
  263.     *Verify required IDC information
  264.     IDC_DataSource=parmsub(getidcp(m.IDCFile,"DataSource"))
  265.     IDC_Template=parmsub(getidcp(m.IDCFile,"Template"))
  266.     IF EMPTY(IDC_Template)
  267.         =Cleanup()
  268.         RETURN errorpage(IDCNOTFOUND1_LOC+IDCFile+IDCBADDATA1_LOC)
  269.     ENDIF
  270.     IDC_SQLStatement=parmsub(getidcp(m.IDCFile,"SQLStatement"))
  271.     IF EMPTY(IDC_SQLStatement)
  272.         =Cleanup()
  273.         RETURN errorpage(IDCNOTFOUND1_LOC+IDCFile+IDCBADDATA2_LOC)
  274.     ENDIF
  275.     DIMENSION laDefaultParameters(1,2)
  276.     IDC_DefaultParameters=getidcp(m.IDCFile,"DefaultParameters",@laDefaultParameters)
  277.     IDC_MaxRecords=VAL(parmsub(getidcp(m.IDCFile,"MaxRecords")))
  278.     IDC_UserName=parmsub(getidcp(m.IDCFile,"UserName"))
  279.     IDC_Password=parmsub(getidcp(m.IDCFile,"Password"))
  280.     IDC_Expires=parmsub(getidcp(m.IDCFile,"Expires"))
  281.     IDC_MaxFieldSize=parmsub(getidcp(m.IDCFile,"MaxFieldSize"))
  282.     DIMENSION laRequiredParameters(1,2)
  283.     IDC_RequiredParameters=getidcp(m.IDCFile,"RequiredParameters",@laRequiredParameters)
  284.     lcSQLStatement=IDC_SQLStatement
  285.     lcTemplate=IDC_Template
  286.  
  287.     *Save server settings
  288.     lcError = ON('ERROR')
  289.  
  290.     *Initialize result page
  291.     cResultPage = 'Content-Type: text/html'+CRLF+CRLF
  292.  
  293.     lFailure = .F.
  294.  
  295.     *Check to see whether we will be accessing an ODBC datasource or native data
  296.     IF EMPTY(IDC_DataSource)
  297.         *NATIVE DATA
  298.         cExecSQLString=lcSQLStatement
  299.         IF EMPTY(cExecSQLString)
  300.             =Cleanup()
  301.             RETURN errorpage(BADSQL_LOC)
  302.         ENDIF
  303.  
  304.         *Execute SQL String and trap for a failure
  305.         _TALLY=0
  306.         lFailure = .F.
  307.         cSQLStatement=cExecSQLString
  308.         *Convert string to UPPERCASE, TRIM, and remove TABs for easy
  309.         *syntax checking.
  310.         cExecSQLString=UPPER(ALLTRIM(STRTRAN(cExecSQLString,CHR(9),' ')))
  311.         *Special case the general SELECT statement without an INTO (the default
  312.         *for Wizard generated stuff.)
  313.         IF cExecSQLString="SELECT " AND ATC(" INTO ",cExecSQLString)=0
  314.             * cExecSQLString needs to carry through the case sensitivity of the
  315.             * original SQL SELECT
  316.             cExecSQLString = cSQLStatement + " INTO CURSOR TempResult"
  317.         ELSE
  318.             IF cExecSQLString="SELECT " OR;
  319.                     cExecSQLString="DELETE " OR;
  320.                     cExecSQLString="INSERT " OR;
  321.                     cExecSQLString="UPDATE " OR;
  322.                     cExecSQLString="ALTER TABLE " OR;
  323.                     cExecSQLString="CREATE CURSOR " OR;
  324.                     cExecSQLString="CREATE TABLE "
  325.                 * cExecSQLString needs to carry through the case sensitivity of the
  326.                 * original SQL SELECT
  327.                 cExecSQLString = cSQLStatement
  328.             ELSE
  329.                 lFailure = .T.
  330.             ENDIF
  331.         ENDIF
  332.         * At this point, if there has been some error evaluating the SQL statement,
  333.         * or if the SQL statement is not one of the above valid types, the lFailure
  334.         * flag is set, and the SQL statement will not be executed.
  335.         IF NOT lFailure
  336.             lnAtPos=ATC(' FROM ',cExecSQLString)
  337.             IF lnAtPos>0
  338.                 lcAlias=ALLTRIM(SUBSTR(cExecSQLString,lnAtPos+6))
  339.                 lnAtPos=AT(' ',lcAlias)
  340.                 IF lnAtPos>0
  341.                     lcAlias=ALLTRIM(LEFT(lcAlias,lnAtPos-1))
  342.                 ENDIF
  343.                 IF LEFT(lcAlias,1)=="'" OR LEFT(lcAlias,1)=='"' OR ;
  344.                         LEFT(lcAlias,1)=='['
  345.                     lcAlias=EVALUATE(lcAlias)
  346.                 ENDIF
  347.                 lcAlias=UPPER(lcAlias)
  348.                 lcFileName=LOWER(lcAlias)
  349.                 lnAtPos=AT('.',lcAlias)
  350.                 IF lnAtPos>0
  351.                     lcAlias=ALLTRIM(LEFT(lcAlias,lnAtPos-1))
  352.                 ENDIF
  353.                 IF NOT '.'$lcFileName
  354.                     lcFileName=lcFileName+'.dbf'
  355.                 ENDIF
  356.                 lcFileName=LOWER(lcFileName)
  357.                 IF NOT FILE(lcFileName)
  358.                     =Cleanup()
  359.                     RETURN errorpage(NOSQL1_LOC+lcFileName+NOSQL2_LOC+cSQLStatement)
  360.                 ENDIF
  361.             ENDIF
  362.             ON ERROR lFailure = .T.
  363.             &cExecSQLString
  364.             ON ERROR &lcError
  365.             IF USED(lcAlias)
  366.                 USE IN (lcAlias)
  367.             ENDIF
  368.         ENDIF
  369.  
  370.  
  371.         IF lFailure = .T.
  372.             IF llDefaultError
  373.                 =Cleanup()
  374.                 RETURN errorpage(BADCMD_LOC+cSQLStatement)
  375.             ELSE
  376.                 CommandSuccess="FALSE"
  377.             ENDIF
  378.         ELSE
  379.             CommandSuccess="TRUE"
  380.         ENDIF
  381.  
  382.         lnRecordsReturned=_TALLY
  383.         IF lnRecordsReturned = 0
  384.             CurrentRecord=0
  385.         ELSE
  386.             CurrentRecord=1
  387.             IF llReturnData
  388.                 RETURN makedata()
  389.             ENDIF
  390.         ENDIF
  391.  
  392.     ELSE
  393.         cExecSQLString=lcSQLStatement
  394.         IF EMPTY(cExecSQLString)
  395.             =Cleanup()
  396.             RETURN errorpage(BADSQL_LOC)
  397.         ENDIF
  398.  
  399.         lnConn=SQLCONNECT(IDC_DataSource,IDC_Username,IDC_Password)
  400.         IF lnConn <= 0
  401.             =Cleanup()
  402.             RETURN errorpage(BADCONN1_LOC+IDC_DataSource+BADCONN2_LOC+IDC_Username+BADCONN3_LOC)
  403.         ENDIF
  404.  
  405.         *Execute SQL String and trap for a failure
  406.         cSQLStatement=cExecSQLString
  407.  
  408.         lnExecRet=0
  409.         DO WHILE lnExecRet=0
  410.             lnExecRet = SQLEXEC(lnConn,cSQLStatement,'TempResult')
  411.         ENDDO
  412.  
  413.         IF lnExecRet < 0
  414.             lFailure = .T.
  415.         ENDIF
  416.  
  417.         =SQLDISCONNECT(lnConn)
  418.  
  419.         IF lFailure = .T.
  420.             IF llDefaultError
  421.                 =Cleanup()
  422.                 RETURN errorpage(BADCMD_LOC+cSQLStatement)
  423.             ELSE
  424.                 CommandSuccess="FALSE"
  425.             ENDIF
  426.         ELSE
  427.             CommandSuccess="TRUE"
  428.         ENDIF
  429.  
  430.         lnRecordsReturned=RECCOUNT('TempResult')
  431.         IF lnRecordsReturned = 0
  432.             CurrentRecord=0
  433.         ELSE
  434.             CurrentRecord=1
  435.             IF llReturnData
  436.                 =Cleanup()
  437.                 RETURN makedata()
  438.             ENDIF
  439.         ENDIF
  440.  
  441.     ENDIF
  442.  
  443.     *Create HTML return page from .HTX and data
  444.  
  445.     *Verify the existence of the Template (.HTX) file.  It must be next to the .IDC file,
  446.     *pathed relative to the .IDC file, or in the Script root.
  447.     lcTmpFile=lcTemplate
  448.     lcTemplate=addbs(justpath(m.IDCFile))+lcTemplate
  449.     IF NOT FILE(lcTemplate)
  450.         lcTemplate=gcScriptRoot+lcTmpFile
  451.         IF NOT FILE(lcTemplate)
  452.             =Cleanup()
  453.             RETURN errorpage(NOTEMPLATE_LOC)
  454.         ENDIF
  455.     ENDIF
  456.  
  457.     lhTemplate=FOPEN(lcTemplate)
  458.     IF lhTemplate < 0
  459.         =Cleanup()
  460.         RETURN errorpage(BADTEMPLATE1_LOC+lcTemplate+BADTEMPLATE2_LOC)
  461.     ENDIF
  462.  
  463.     llGetNewLine=.T.
  464.  
  465.     DO WHILE NOT FEOF(lhTemplate)
  466.         IF llGetNewLine
  467.             lcLine=FGETS(lhTemplate)
  468.         ELSE
  469.             *Toggle GetNewLine back to True
  470.             llGetNewLine=.T.
  471.         ENDIF
  472.         lcLineCopy=UPPER(lcLine)
  473.         DO CASE
  474.             *The BeginDetail structure is linear, but must be repeated for
  475.             *each record in the return set.  IFs can be nested within a Detail
  476.             *section, so, once the detail section is loaded, it must be parsed
  477.             *for IFs.  However
  478.         CASE "<%BEGINDETAIL%>" $ lcLineCopy
  479.             *If the BEGINDETAIL is not at the beginning of the line, put the
  480.             *prefix into the Result page.  Then work on the detail chunk.
  481.             IF lcLineCopy != "<%BEGINDETAIL%>"
  482.                 cResultPage=cResultPage+SUBSTR(lcLine,1,AT("<%BEGINDETAIL%>",lcLineCopy)-1)
  483.                 lcLine=SUBSTR(lcLine,AT("<%BEGINDETAIL%>",lcLineCopy)+15)+CRLF
  484.             ELSE
  485.                 *If there's stuff after the BEGINDETAIL symbol, stuff it into the lcLine
  486.                 IF LEN(lcLine)>LEN("<%BEGINDETAIL%>")
  487.                     lcLine=SUBSTR(lcLine,16)
  488.                 ELSE
  489.                     lcLine=""
  490.                 ENDIF
  491.             ENDIF
  492.             llDone=.F.
  493.             IF NOT EMPTY(lcLine)
  494.                 IF "<%ENDDETAIL%>" $ UPPER(lcLine)
  495.                     lcTmpLine=lcLine
  496.                     IF UPPER(lcTmpLine)!="<%ENDDETAIL%>"
  497.                         lcLine=SUBSTR(lcTmpLine,1,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))-1)
  498.                     ENDIF
  499.                     IF LEN(lcTmpLine)>LEN("<%ENDDETAIL%>")
  500.                         lcSuffix=SUBSTR(lcTmpLine,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))+13)
  501.                     ELSE
  502.                         lcSuffix=""
  503.                     ENDIF
  504.                     llDone=.T.
  505.                 ENDIF
  506.             ENDIF
  507.             DO WHILE NOT llDone AND NOT FEOF(lhTemplate)
  508.                 lcTmpLine=FGETS(lhTemplate)
  509.                 IF NOT("<%ENDDETAIL%>" $ UPPER(lcTmpLine))
  510.                     *Add to the block until you hit an ENDDETAIL
  511.                     lcLine=lcLine+lcTmpLine+CRLF
  512.                 ELSE
  513.                     *Add everything up to the beginning of the ENDDETAIL and store everything
  514.                     *afterward in lcSuffix for processing later.
  515.                     IF UPPER(lcTmpLine)!="<%ENDDETAIL%>"
  516.                         lcLine=lcLine+SUBSTR(lcTmpLine,1,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))-1)
  517.                     ENDIF
  518.                     IF LEN(lcTmpLine)>LEN("<%ENDDETAIL%>")
  519.                         lcSuffix=SUBSTR(lcTmpLine,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))+13)
  520.                     ELSE
  521.                         lcSuffix=""
  522.                     ENDIF
  523.                     llDone=.T.
  524.                 ENDIF
  525.             ENDDO
  526.             IF NOT llDone
  527.                 *Error: Mismatched Begin/EndDetail, close template file and exit
  528.                 =FCLOSE(lhTemplate)
  529.                 =Cleanup()
  530.                 RETURN errorpage(BADTEMPLATE1_LOC+lcTemplate+BADTEMPLATE3_LOC)
  531.             ENDIF
  532.             IF lnRecordsReturned > 0
  533.                 lcDetailExec=''
  534.                 DO WHILE AT("<%",lcLine) > 0
  535.                     lcDetailExec=lcDetailExec+'"'+STRTRAN(SUBSTR(lcLine,1,AT("<%",lcLine)-1),'"','"+["]+"')+'"+'
  536.                     lcLine=SUBSTR(lcLine,AT("<%",lcLine))
  537.                     IF UPPER(lcLine)="<%IF "
  538.                         *Process the IF structure into an IIF
  539.                         *Trim the IF and ENDIF symbols.
  540.                         lcIfStatement=SUBSTR(lcLine,6,AT("<%ENDIF%>",UPPER(lcLine))-6)
  541.                         *Strip out Expression 1, Expression 2, and the Operator
  542.                         lcExp1=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  543.                         lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  544.                         lcOperator=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  545.                         lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  546.                         lcExp2=ALLT(SUBSTR(lcIfStatement,1,AT("%>",lcIfStatement)-1))
  547.                         lcIfStatement=SUBSTR(lcIfStatement,AT("%>",lcIfStatement)+2)
  548.                         IF NOT('"'$lcExp1 OR "'"$lcExp1 OR '['$lcExp1)
  549.                             lcExp1=UPPER(lcExp1)
  550.                             lcExp1=STRTRAN(lcExp1,"IDC.","IDC_")
  551.                         ENDIF
  552.                         IF NOT('"'$lcExp2 OR "'"$lcExp2 OR '['$lcExp2)
  553.                             lcExp2=UPPER(lcExp2)
  554.                             lcExp2=STRTRAN(lcExp2,"IDC.","IDC_")
  555.                         ENDIF
  556.                         lcOperator=UPPER(lcOperator)
  557.                         DO CASE
  558.                         CASE lcOperator="CONTAINS"
  559.                             lcTmpExp=lcExp2
  560.                             lcExp2=lcExp1
  561.                             lcExp1=lcTmpExp
  562.                             lcOperator="$"
  563.                         CASE lcOperator="EQ"
  564.                             lcOperator="="
  565.                         CASE lcOperator="GT"
  566.                             lcOperator=">"
  567.                         CASE lcOperator="LT"
  568.                             lcOperator="<"
  569.                         ENDCASE
  570.                         IF "<%ELSE%>"$UPPER(lcIfStatement)
  571.                             lcTrueStatement=SUBSTR(lcIfStatement,1,AT("<%ELSE%>",UPPER(lcIfStatement))-1)
  572.                             lcIfStatement=SUBSTR(lcIfStatement,AT("<%ELSE%>",UPPER(lcIfStatement))+8)
  573.                             lcFalseStatement=lcIfStatement
  574.                             lcFalseStatement=STRTRAN(lcFalseStatement,'"','"+["]+"')
  575.                         ELSE
  576.                             lcTrueStatement=lcIfStatement
  577.                             lcFalseStatement=""
  578.                         ENDIF
  579.                         lcTrueStatement=STRTRAN(lcTrueStatement,'"','"+["]+"')
  580.                         lcIIF='IIF('+lcExp1+lcOperator+lcExp2+',"'+lcTrueStatement+'","'+lcFalseStatement+'")+'
  581.                         lcDetailExec=lcDetailExec+lcIIF
  582.                         IF LEN(lcLine)>AT("<%ENDIF%>",UPPER(lcLine))+9
  583.                             lcLine=SUBSTR(lcLine,AT("<%ENDIF%>",UPPER(lcLine))+9)
  584.                         ELSE
  585.                             lcLine=""
  586.                         ENDIF
  587.                     ELSE
  588.                         *This is a symbol structure.  If it is valid, extract the symbol and place it into
  589.                         *the executable line.
  590.                         IF AT("%>",lcLine)=0
  591.                             =FCLOSE(lhTemplate)
  592.                             =Cleanup()
  593.                             RETURN errorpage(BADTEMPLATE4_LOC+lcTemplate+BADTEMPLATE5_LOC)
  594.                         ENDIF
  595.                         lcSymbol=SUBSTR(lcLine,3,AT("%>",lcLine)-3)
  596.                         lcDetailExec=lcDetailExec+'EXPTOC('+ALLT(lcSymbol)+')+'
  597.                         IF LEN(lcLine)>LEN(lcSymbol)+4
  598.                             lcLine=SUBSTR(lcLine,AT("%>",lcLine)+2)
  599.                         ELSE
  600.                             lcLine=""
  601.                         ENDIF
  602.                     ENDIF
  603.                 ENDDO
  604.                 lcDetailExec=lcDetailExec+'"'+STRTRAN(lcLine,'"','"+["]+"')+'"'
  605.                 =DetailEx(lcDetailExec,@laEnvVariables,@cResultPage)
  606.             ENDIF
  607.             *If the suffix has stuff to process, then don't get a new file line, start with the suffix.
  608.             IF NOT EMPTY(lcSuffix)
  609.                 llGetNewLine=.F.
  610.                 lcLine=lcSuffix
  611.             ENDIF
  612.         CASE "<%IF" $ lcLineCopy
  613.             IF lcLineCopy != "<%IF "
  614.                 cResultPage=cResultPage+SUBSTR(lcLine,1,AT("<%IF ",lcLineCopy)-1)
  615.                 lcLine=SUBSTR(lcLine,AT("<%IF ",lcLineCopy)+5)+CRLF
  616.             ELSE
  617.                 IF LEN(lcLine)>LEN("<%IF ")
  618.                     lcLine=SUBSTR(lcLine,5)
  619.                 ELSE
  620.                     =FCLOSE(lhTemplate)
  621.                     =Cleanup()
  622.                     RETURN errorpage(BADTEMPLATE6_LOC)
  623.                 ENDIF
  624.             ENDIF
  625.             llDone=.F.
  626.             DO WHILE NOT llDone AND NOT FEOF(lhTemplate)
  627.                 lcTmpLine=FGETS(lhTemplate)
  628.                 IF NOT("<%ENDIF%>" $ UPPER(lcTmpLine))
  629.                     lcLine=lcLine+lcTmpLine+CRLF
  630.                 ELSE
  631.                     *Add everything up to the beginning of the ENDIF and store everything
  632.                     *afterward in lcSuffix for processing later.
  633.                     IF UPPER(lcTmpLine)!="<%ENDIF%>"
  634.                         lcLine=lcLine+SUBSTR(lcTmpLine,1,AT("<%ENDIF%>",UPPER(lcTmpLine))-1)
  635.                     ENDIF
  636.                     IF LEN(lcTmpLine)>LEN("<%ENDIF%>")
  637.                         lcSuffix=SUBSTR(lcTmpLine,AT("<%ENDIF%>",UPPER(lcTmpLine))+9)
  638.                     ELSE
  639.                         lcSuffix=""
  640.                     ENDIF
  641.                     llDone=.T.
  642.                 ENDIF
  643.             ENDDO
  644.             IF NOT llDone
  645.                 *Error: Mismatched If/Endif, close template file and exit
  646.                 =FCLOSE(lhTemplate)
  647.                 =Cleanup()
  648.                 RETURN errorpage(BADTEMPLATE1_LOC+lcTemplate+BADTEMPLATE7_LOC)
  649.             ENDIF
  650.             *At this point, the entire structure between the <%IF and the <%ENDIF%> non inclusive is
  651.             *in lcLine.  This will include the conditional parameters and an <%ELSE%> if such a thing exists.
  652.             *In addition, everything after the structure will be contained in lcSuffix.
  653.             lcIfStatement=LTRIM(lcLine)
  654.             *Strip out Expression 1, Expression 2, and the Operator
  655.             lcExp1=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  656.             lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  657.             lcOperator=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  658.             lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  659.             lcExp2=ALLT(SUBSTR(lcIfStatement,1,AT("%>",lcIfStatement)-1))
  660.             lcIfStatement=SUBSTR(lcIfStatement,AT("%>",lcIfStatement)+2)
  661.             *If the expressions aren't character literals, make them uppercase
  662.             *for case insensitivity.  Also check to see if they reference IDC.
  663.             *variables at this point.
  664.             IF NOT('"'$lcExp1 OR "'"$lcExp1 OR '['$lcExp1)
  665.                 lcExp1=UPPER(lcExp1)
  666.                 lcExp1=STRTRAN(lcExp1,"IDC.","IDC_")
  667.             ENDIF
  668.             IF NOT('"'$lcExp2 OR "'"$lcExp2 OR '['$lcExp2)
  669.                 lcExp2=UPPER(lcExp2)
  670.                 lcExp2=STRTRAN(lcExp2,"IDC.","IDC_")
  671.             ENDIF
  672.             lcOperator=UPPER(lcOperator)
  673.             DO CASE
  674.             CASE lcOperator="CONTAINS"
  675.                 lcTmpExp=lcExp2
  676.                 lcExp2=lcExp1
  677.                 lcExp1=lcTmpExp
  678.                 lcOperator="$"
  679.             CASE lcOperator="EQ"
  680.                 lcOperator="="
  681.             CASE lcOperator="GT"
  682.                 lcOperator=">"
  683.             CASE lcOperator="LT"
  684.                 lcOperator="<"
  685.             ENDCASE
  686.             IF "<%ELSE%>"$UPPER(lcIfStatement)
  687.                 lcTrueStatement=SUBSTR(lcIfStatement,1,AT("<%ELSE%>",UPPER(lcIfStatement))-1)
  688.                 lcIfStatement=SUBSTR(lcIfStatement,AT("<%ELSE%>",UPPER(lcIfStatement))+8)
  689.                 lcFalseStatement=lcIfStatement
  690.             ELSE
  691.                 lcTrueStatement=lcIfStatement
  692.                 lcFalseStatement=""
  693.             ENDIF
  694.             IF EvalCond(lcExp1+lcOperator+lcExp2,@laEnvVariables)
  695.                 lcLine=lcTrueStatement+lcSuffix
  696.             ELSE
  697.                 lcLine=lcFalseStatement+lcSuffix
  698.             ENDIF
  699.             IF NOT EMPTY(lcLine)
  700.                 llGetNewLine=.F.
  701.             ENDIF
  702.         OTHERWISE
  703.             cResultPage=cResultPage+lcLine+CRLF
  704.         ENDCASE
  705.     ENDDO
  706.     IF lnRecordsReturned=0
  707.         cResultPage=cResultPage+NOMATCHES_LOC+CRLF
  708.     ENDIF
  709.  
  710.     *Append query log
  711.     lnSelect=SELECT()
  712.     SELECT QueryLog
  713.     INSERT INTO QueryLog (TimeStamp, IDCFile, Parameters) ;
  714.             VALUES (DATETIME(), lcIDCFile, RETURNED_LOC)
  715.     SELECT 0
  716.  
  717.     =FCLOSE(lhTemplate)
  718.  
  719.     =Cleanup()
  720.     RETURN cResultPage
  721.  
  722. PROCEDURE Cleanup()
  723.     LOCAL lnCount
  724.  
  725.     IF USED('TempResult')
  726.         USE IN TempResult
  727.     ENDIF
  728.  
  729. PROCEDURE errorpage (lcErrorMessage)
  730.     LOCAL cResultPage
  731.     cResultPage = 'Content-Type: text/html'+CRLF+CRLF
  732.  
  733.     cResultPage = cResultPage + ;
  734.         '<html><head><title>'+FAILEDSEARCH_LOC+'</title></head>'+ ;
  735.         CRLF
  736.     cResultPage = cResultPage + ;
  737.         '<body>'+CRLF
  738.     cResultPage = cResultPage + ;
  739.         '<h1>'+FAILEDSEARCH_LOC+'</h1>'+CRLF
  740.  
  741.     cResultPage = cResultPage + ;
  742.         ' '+ALLT(lcErrorMessage)+'<hr></body></html>'+CRLF
  743.  
  744.     RETURN cResultPage
  745.  
  746. FUNCTION FormFld(FldValue)
  747.     FldValue=STRTRAN(FldValue,CRLF,"<BR>")
  748.     IF RIGHT(FldValue,4)="<BR>"
  749.         FldValue=SUBSTR(FldValue,1,LEN(FldValue)-4)
  750.     ENDIF
  751.     RETURN FldValue
  752.  
  753. FUNCTION MakeData
  754.     LOCAL cResultPage,cFileName,nFH,nFSize
  755.     cResultPage="<Content-type:text/plain>"+CRLF
  756.     cFileName=SYS(3)+'.TXT'
  757.     SELECT TempResult
  758.     IF IDC_MaxRecords > 0
  759.         LIST NEXT IDC_MaxRecords TO FILE (cFileName) NOCONSOLE
  760.     ELSE
  761.         LIST TO FILE (cFileName) NOCONSOLE
  762.     ENDIF
  763.     nFH=FOPEN(cFileName)
  764.  
  765.     IF nFH > 0
  766.         nFSize=FSEEK(nFH,0,2)
  767.         =FSEEK(nFH,0,0)
  768.         cResultPage=cResultPage+FREAD(nFH,nFSize)
  769.     ELSE
  770.         RETURN ErrorPage(NODATASTREAM_LOC)
  771.     ENDIF
  772.     =FCLOSE(nFH)
  773.     ERASE (cFileName)
  774.     RETURN cResultPage
  775.  
  776.  
  777.  
  778. FUNCTION bldpath
  779.     LOCAL lcPath, lcRefer, lcSubPath
  780.  
  781.     lcPath=gcHTTPRoot
  782.  
  783.     lcRefer=getparam("HTTP_REFERER")
  784.     IF NOT EMPTY(lcRefer)
  785.         lcRefer=STRTRAN(lcRefer,"//","")
  786.         lcRefer=STRTRAN(lcRefer,"/","\")
  787.         lcRefer=SUBSTR(lcRefer,AT("\",lcRefer)+1)
  788.         lcRefer=LEFT(lcRefer,RAT("\",lcRefer))
  789.     ENDIF
  790.  
  791.     lcPath=lcPath+lcRefer
  792.  
  793.     RETURN lcPath
  794.  
  795.  
  796.  
  797. FUNCTION DetailEx(lcDetailLine,laSymbolTable,cResultPage)
  798.     EXTERNAL ARRAY laSymbolTable
  799.     LOCAL lnMaxRecords,lnCount
  800.  
  801.     IF IDC_MaxRecords > 0
  802.         lnMaxRecords=MIN(IDC_MaxRecords,lnRecordsReturned)
  803.     ELSE
  804.         lnMaxRecords=lnRecordsReturned
  805.     ENDIF
  806.  
  807.     *Execute IIF with local environment
  808.     lcDetailLine=STRTRAN(lcDetailLine,CRLF,"")
  809.  
  810.     SELECT TempResult
  811.  
  812.     lnCount=0
  813.     SCAN REST
  814.         IF lnCount>=lnMaxRecords
  815.             EXIT
  816.         ENDIF
  817.         lnCount=lnCount+1
  818.         cResultPage=cResultPage+EVALUATE(lcDetailLine)+CRLF
  819.         CurrentRecord=CurrentRecord+1
  820.     ENDSCAN
  821.  
  822.     IF CurrentRecord > 0
  823.         CurrentRecord=1
  824.     ENDIF
  825.  
  826.     RETURN
  827.  
  828.  
  829.  
  830.     *This function takes a conditional statement and evaluates it based on the
  831.     *entire environment state at this time.
  832.  
  833. FUNCTION EvalCond(lcConditional,laSymbolTable)
  834.     EXTERNAL ARRAY laSymbolTable
  835.  
  836.     RETURN EVALUATE(lcConditional)
  837.  
  838.  
  839.  
  840. FUNCTION exptoc(eExprVal)
  841.  
  842.     DO CASE
  843.     CASE ISNULL(eExprVal)
  844.         RETURN 'NULL'
  845.     CASE TYPE('eExprVal') $ 'CM'
  846.         RETURN ALLTRIM(eExprVal)
  847.     CASE TYPE('eExprVal') $ 'NFYB'
  848.         RETURN ALLTRIM(STR(eExprVal))
  849.     CASE TYPE('eExprVal') $ 'L'
  850.         RETURN ALLTRIM(IIF(eExprVal,TRUE_LOC,FALSE_LOC))
  851.     CASE TYPE('eExprVal') $ 'D'
  852.         RETURN ALLTRIM(DTOC(eExprVal))
  853.     CASE TYPE('eExprVal') $ 'T'
  854.         RETURN ALLTRIM(TTOC(eExprVal))
  855.     OTHERWISE
  856.         RETURN '*****'
  857.     ENDCASE
  858.  
  859.  
  860.  
  861.     * Function GETIDCP (Get IDC Parameters)
  862.     * Fetches requested parameter from the IDC file and returns the
  863.     * value as a character string.  This function has a polymorphic
  864.     * return type: in the case where the DefaultParameters parameter is
  865.     * fetched, the function returns a numeric value indicating how many
  866.     * default parameters were fetched.  The parameters and values are stored
  867.     * in the passed-by-reference array as a parameter,value pair.
  868.     * Errors result in the null string being returned.
  869.  
  870. FUNCTION getidcp(cIDCFile,cParameter,aDefArray)
  871.  
  872.     IF PARAMETERS()<2
  873.         RETURN ""
  874.     ENDIF
  875.  
  876.     llFound=.F.
  877.  
  878.     cParameter=ALLT(cParameter)
  879.     cIDCFile=ALLT(cIDCFile)
  880.  
  881.     lhIDC=FOPEN(cIDCFile)
  882.  
  883.     IF lhIDC < 0
  884.         RETURN ""
  885.     ENDIF
  886.  
  887.     DO WHILE NOT llFound AND NOT FEOF(lhIDC)
  888.         lcLine=FGETS(lhIDC)
  889.         IF NOT EMPTY(lcLine)
  890.             lcLineTok=UPPER(STRTRAN(lcLine," ",""))
  891.             IF (UPPER(cParameter)+":")$lcLineTok
  892.                 llFound=.T.
  893.             ENDIF
  894.         ENDIF
  895.     ENDDO
  896.  
  897.     IF NOT llFound
  898.         =FCLOSE(lhIDC)
  899.         RETURN ""
  900.     ENDIF
  901.  
  902.     llDone=.F.
  903.     DO WHILE NOT llDone AND NOT FEOF(lhIDC)
  904.         lcAddLine=ALLT(FGETS(lhIDC))
  905.         IF LEFT(lcAddLine,1) = "+"
  906.             lcLine=lcLine+" "+ALLT(SUBSTR(lcAddLine,2))
  907.         ELSE
  908.             llDone=.T.
  909.         ENDIF
  910.     ENDDO
  911.  
  912.     =FCLOSE(lhIDC)
  913.  
  914.     *Add filler so AT will never fail.
  915.     lcLine=lcLine+" "
  916.  
  917.     lcValue=LTRIM(SUBSTR(lcLine,AT(":",lcLine)+1))
  918.  
  919.     IF UPPER(cParameter)="DEFAULTPARAMETERS" OR UPPER(cParameter)="REQUIREDPARAMETERS"
  920.         lnParameters=0
  921.         DO WHILE AT("=",lcValue)>0
  922.             * Add filler so loop works in 0 case
  923.             lcValue=lcValue+", "
  924.             lnParameters=lnParameters+1
  925.             DIMENSION aDefArray(lnParameters,2)
  926.             aDefArray(lnParameters,1)=ALLT(SUBSTR(lcValue,1,AT("=",lcValue)-1))
  927.             aDefArray(lnParameters,2)=ALLT(SUBSTR(lcValue,AT("=",lcValue)+1,AT(",",lcValue)-(AT("=",lcValue)+1)))
  928.             lcValue=SUBSTR(lcValue,AT(",",lcValue)+1)
  929.         ENDDO
  930.         RETURN lnParameters
  931.     ENDIF
  932.  
  933.     RETURN lcValue
  934.  
  935.  
  936.  
  937. FUNCTION getparam
  938.     LPARAMETER cVar
  939.     EXTERNAL ARRAY laEnvVariables
  940.  
  941.     LOCAL nLocation, llDone, nFrom
  942.  
  943.     llDone=.F.
  944.     nFrom=1
  945.  
  946.     *Find the given variable in the first column of the environment variables array if
  947.     *it's there at all.
  948.     DO WHILE llDone=.F.
  949.         nLocation=ASCAN(laEnvVariables,cVar,nFrom)
  950.         IF nLocation=0
  951.             llDone=.T.
  952.         ELSE
  953.             IF ASUBSCRIPT(laEnvVariables,nLocation,2) = 1
  954.                 llDone=.T.
  955.             ELSE
  956.                 nFrom=nLocation+1
  957.             ENDIF
  958.         ENDIF
  959.     ENDDO
  960.  
  961.     IF nLocation > 0
  962.         RETURN laEnvVariables[ASUBSCRIPT(laEnvVariables,nLocation+1,1),ASUBSCRIPT(laEnvVariables,nLocation+1,2)]
  963.     ELSE
  964.         RETURN ""
  965.     ENDIF
  966.  
  967.  
  968.  
  969. FUNCTION GetToken(INSTR,innum,insep)
  970.     **  GetToken.
  971.     **    Parameters:
  972.     **    1) Input string to be parsed.
  973.     **  2) Number of token to return.
  974.     **    3) The delimiter that seperates tokens.  (Default ",")
  975.     PRIVATE ALL
  976.  
  977.     IF PARAM() < 2
  978.         RETURN ""
  979.     ENDIF
  980.  
  981.     IF PARAM() < 3
  982.         insep = ","
  983.     ENDIF
  984.  
  985.     maxnum = OCCURS(insep,INSTR)
  986.  
  987.     DO CASE
  988.     CASE innum <= 0
  989.         rval = ""
  990.     CASE maxnum = 0 AND innum = 1
  991.         rval = INSTR
  992.     CASE maxnum = 0 AND innum > 1
  993.         rval = ""
  994.     CASE maxnum > 0 AND innum = 1
  995.         rval = SUBSTR(INSTR,1,ATC(insep,INSTR)-1)
  996.     CASE innum = maxnum + 1 AND LEN(INSTR) < ATC(insep,INSTR,maxnum)+1
  997.         rval = ""
  998.     CASE innum = maxnum + 1
  999.         start = ATC(insep,INSTR,maxnum)+1
  1000.         stop = LEN(INSTR)
  1001.         rval = SUBSTR(INSTR,start,stop-start+1)
  1002.     CASE innum < maxnum + 1
  1003.         start = ATC(insep,INSTR,innum-1)+1
  1004.         stop = ATC(insep,INSTR,innum)-1
  1005.         rval = SUBSTR(INSTR,start,stop-start+1)
  1006.     CASE innum > maxnum + 1
  1007.         rval = ""
  1008.  
  1009.     ENDCASE
  1010.     RETURN rval
  1011.  
  1012.  
  1013.  
  1014. FUNCTION isnum(lcNumber)
  1015.  
  1016.     IF EMPTY(lcNumber)
  1017.         RETURN .F.
  1018.     ENDIF
  1019.  
  1020.     lcNumber=UPPER(lcNumber)
  1021.  
  1022.     *Make sure there's not more than one of each E,-, and .
  1023.  
  1024.     IF STRTRAN(lcNumber,".","",1,1)!=STRTRAN(lcNumber,".","")
  1025.         RETURN .F.
  1026.     ENDIF
  1027.     IF STRTRAN(lcNumber,"E","",1,1)!=STRTRAN(lcNumber,"E","")
  1028.         RETURN .F.
  1029.     ENDIF
  1030.     IF STRTRAN(lcNumber,"-","",1,1)!=STRTRAN(lcNumber,"-","")
  1031.         RETURN .F.
  1032.     ENDIF
  1033.  
  1034.     IF CHRTRAN(lcNumber,"0123456789.E-",REPL(CHR(0),13))==REPL(CHR(0),LEN(lcNumber))
  1035.         RETURN .T.
  1036.     ELSE
  1037.         RETURN .F.
  1038.     ENDIF
  1039.  
  1040.  
  1041.  
  1042. FUNCTION parmsub(lcRootString)
  1043.     EXTERNAL ARRAY laEnvVariables
  1044.  
  1045.     lcFilledString=lcRootString
  1046.  
  1047.     *Iterate through for each possible environment variable.  Faster than parsing everything out.
  1048.  
  1049.     FOR nCnt=1 TO lnEnvVariables
  1050.         lcFilledString=STRTRAN(lcFilledString,"%"+ALLT(laEnvVariables[nCnt,1])+"%",laEnvVariables[nCnt,2])
  1051.     ENDFOR
  1052.  
  1053.     RETURN lcFilledString
  1054.  
  1055.  
  1056.  
  1057. FUNCTION ParseVars(cParameters,laEnvVariables,llCreate)
  1058.  
  1059.     LOCAL nVCount, cToken
  1060.  
  1061.     IF EMPTY(cParameters)
  1062.         RETURN 0
  1063.     ENDIF
  1064.  
  1065.     IF llCreate
  1066.         nVCount=1
  1067.     ELSE
  1068.         nVCount=ALEN(laEnvVariables,1)+1
  1069.     ENDIF
  1070.     cToken=GETTOKEN(cParameters,1,"&")
  1071.     DO WHILE NOT EMPTY(cToken)
  1072.         DIMENSION laEnvVariables[nVCount,2]
  1073.         laEnvVariables[nVCount,1]=ALLT(SUBSTR(cToken,1,ATC("=",cToken)-1))
  1074.         IF ATC("=",cToken)=LEN(cToken)
  1075.             laEnvVariables[nVCount,2]=""
  1076.         ELSE
  1077.             cToken = SUBSTR(cToken,ATC("=",cToken)+1)
  1078.             cToken = StripASCII(cToken)
  1079.             laEnvVariables[nVCount,2] = STRTRAN(cToken,"+"," ")
  1080.         ENDIF
  1081.         nVCount=nVCount+1
  1082.         cToken=GETTOKEN(cParameters,nVCount,"&")
  1083.     ENDDO
  1084.  
  1085.     nVCount=nVCount-1
  1086.  
  1087.     RETURN nVCount
  1088.  
  1089. FUNCTION StripASCII
  1090.     LPARAMETER clString
  1091.     * clString is ASCII, but could contain hex of DBCS
  1092.     LOCAL m.cstr, m.nextflag, m.lastflag, m.numflags
  1093.     
  1094.     m.nextflag = AT_C("%",m.clString)
  1095.     IF m.nextflag = 0
  1096.         *  If no % symbol, do not need to modify string.
  1097.         RETURN m.clString
  1098.     ENDIF
  1099.     
  1100.     m.cStr = ""
  1101.     m.lastflag = 1
  1102.     m.numflags = 1
  1103.     DO WHILE .T.
  1104.         *  Get text before current % flag.
  1105.         m.cStr = m.cStr + ;
  1106.                 SUBSTR(m.clString,m.lastflag, m.nextflag - m.lastflag) + ;
  1107.                 CHR(EVALUATE("0x" + SUBSTR(m.clString,m.nextflag + 1,2)))
  1108.         m.lastflag = m.nextflag + 3    && skip past item.
  1109.         m.numflags = m.numflags + 1
  1110.         m.nextflag = AT_C("%", m.clString, m.numflags)
  1111.         IF m.nextflag = 0
  1112.             m.cStr = m.cStr + SUBSTR(m.clString, m.lastflag)
  1113.             EXIT
  1114.         ENDIF
  1115.     ENDDO
  1116.     RETURN m.cStr
  1117.  
  1118.  
  1119. FUNCTION readini(filename)
  1120.  
  1121.     PRIVATE pcfg,prdline,ptoken,pvalue
  1122.  
  1123.     pcfg = FOPEN(filename)
  1124.  
  1125.     IF pcfg < 0
  1126.         RETURN .F.
  1127.     ENDIF
  1128.  
  1129.     DO WHILE NOT(FEOF(pcfg))
  1130.         prdline = FGETS(pcfg)
  1131.         IF NOT EMPTY(prdline)
  1132.             ptoken = UPPER(ALLTRIM(SUBSTR(prdline,1,AT("=",prdline)-1)))
  1133.             pvalue = UPPER(ALLTRIM(SUBSTR(prdline,AT("=",prdline)+1)))
  1134.             DO CASE
  1135.             CASE ptoken == "HTTPROOT"
  1136.                 gcHTTPRoot = pvalue
  1137.             CASE ptoken == "SCRIPTROOT"
  1138.                 gcScriptRoot = pvalue
  1139.             CASE ptoken == "SEMAPHORE"
  1140.                 gcSemaphoreRoot = pvalue
  1141.             CASE ptoken == "PATH"
  1142.                 gcPath = pvalue
  1143.             ENDCASE
  1144.         ENDIF
  1145.     ENDDO
  1146.  
  1147.     =FCLOSE(pcfg)
  1148.  
  1149.     RETURN .T.
  1150.  
  1151.  
  1152.  
  1153. FUNCTION runspec
  1154.     gcINIFile='is.ini'
  1155.     gcHTTPRoot=""
  1156.     gcScriptRoot=""
  1157.  
  1158.     DO FORM specroot
  1159.     RETURN
  1160.  
  1161.  
  1162.  
  1163. FUNCTION ErrorHandler(tnErrorNo,tcMsg,tcProgramName,tnLineNo,tcCodeLine)
  1164. LOCAL laDir[1]
  1165.  
  1166.     IF ADIR(laDir,'error.txt')>0
  1167.         IF laDir[2]>65535 OR (DATE()-laDir[3])>14
  1168.             ERASE error.txt
  1169.         ENDIF
  1170.     ENDIF
  1171.     SET TEXTMERGE OFF
  1172.     SET TEXTMERGE TO ERROR ADDITIVE
  1173.     SET TEXTMERGE ON NOSHOW
  1174.     
  1175.     \<<ERROCCUR_LOC>><<DATETIME()>>
  1176.     \<<ERRMESS_LOC>><<tcMsg>>
  1177.     \<<ERRNUM_LOC>><<tnErrorNo>>
  1178.     \<<ERRPROC_LOC>><<PROPER(tcProgramName)>>
  1179.     \<<ERRLINE_LOC>><<tnLineNo>>
  1180.     IF NOT EMPTY(ALIAS())
  1181.     \<<ERRALIAS_LOC>>[<<ALIAS()>>]
  1182.     \<<ERRREC_LOC>><<RECNO()>>
  1183.     ENDIF
  1184.     \<<tcCodeLine>>
  1185.     \
  1186.     \
  1187.     SET TEXTMERGE OFF
  1188.     SET TEXTMERGE TO
  1189. ENDFUNC